COMMENT ⊗   VALID 00002 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	 This is a program to typeset Lisp code in TEX82
C00008 ENDMK
C⊗;
;;; This is a program to typeset Lisp code in TEX82
(declare (array* (fixnum lines 2)))
(declare (special lines -em:sfa- -em:filemode-)(*expr em:message-align)
	 (setq defmacro-for-compiling ()))

(array lines fixnum 200. 200.)

(defmacro init ()
	  `(progn
	    (setq cl (other cl))
	    (setq leftmost t)
	    (setq old-marks new-marks)
	    (setq new-marks ())
	    (setq old-cleartabs new-cleartabs)
	    (setq new-cleartabs ())
	    (setq fp 0)))

(defun clear-line (n)
       (do ((i 0 (1+ i)))
	   ((= i 200.) t)
	   (store (lines n i) 0)))

(defmacro other (n)
	  `(cond ((= ,n 0) 1)
		 (t 0)))

(defmacro left-of-a-mark ()
	  `(do ((marks old-marks (cdr marks))
		(leftp ()))
	       ((null marks) leftp)
	       (cond 
		((< fp (car marks))
		 (setq leftp t)))))

(defmacro under-something ()
	  `(let ((above (lines (other cl) fp)))
		(or (= 0 fp)
		    (and (not (= above #o40))
			 (member (lines (other cl) (1- fp)) '(#o50 #o40))))))

(defmacro insert-cleartabs (n)
	  `(push ,n new-cleartabs))

(defmacro insert-ampersand (n)
	  `(progn (push ,n new-marks)
		  (or (member ,n old-marks)(push ,n old-marks))))

(defun output-ampersand-preface (marks cl)
       (let ((fp 0))
	    (do ((tok (lines cl fp) (lines cl p))
		 (p 0 (1+ p)))
		((not (= tok #o40))
		 fp)
		(cond ((member p marks)
		       (setq fp p)
		       (princ "&"))))))

(defmacro output-last-line ()
	  `(progn 
	    (setq old-marks (reverse old-marks))
	    (princ "\+")
	    (do ((p (output-ampersand-preface old-marks (other cl)) (1+ p))
		 (ocl (other cl)))
		((= (lines ocl p) 0)
		 (princ "\cr")
		 (terpri)
		 (clear-line ocl)
		 (init))
		(cond ((member p old-marks) (princ "&")))
		(cond ((member p old-cleartabs) (princ "\cleartabs ")))
		(tyo (lines ocl p)))))

(defmacro inc (x)
	  `(setq ,x (1+ ,x)))

(defmacro read-rest-of-line ()
	  `(do ((token (tyi f -1) (tyi f -1)))
	       ((or (= token -1)
		    (= token #o26))
		(return ()))
	       (cond ((member token '(#o12 #o15))
		      (tyi f)
		      (return ()))
		     (t (store (lines cl fp) token)
			(inc fp)))))

(defun ltypeset ()
       (princ "\settabs\+\cr")
       (terpri)
       (let ((-em:filemode- t)
	     (f -em:sfa-))
 	    (em:message-align)
	    (let ((new-marks ())
		  (old-marks ())(new-cleartabs ())(old-cleartabs ())
		  (fp 0)(leftmost t)(cl 0))
		 (do ((token (tyi f -1) (tyi f -1))
		      (end-of-first-line ()))
		     ((or end-of-first-line
			  (= token #o26)
			  (= token -1))
		      (init)
		      (do ((token (tyi f -1) (tyi f -1)))
			  ((or (= token -1)
			       (= token #o26))
			   (output-last-line) t)
			  (cond ((member token '(#o12 #o15))
				 (tyi f)
				 (output-last-line))
				((= token #o11)
				 (break tab-found t))
				((not (= token #o40))
				 (store (lines cl fp) token)
				 (cond ((and old-marks
					     (left-of-a-mark fp))
					(insert-cleartabs fp)
					(cond ((member fp old-marks)
					       (insert-ampersand fp)))
					(store (lines cl fp) token)
					(inc fp)
					(read-rest-of-line)
					(output-last-line))
				       ((under-something fp)
					(insert-ampersand fp)
					(store (lines cl fp) token)
					(inc fp)
					(read-rest-of-line)
					(output-last-line))
				       (t 
					  (store (lines cl fp) token)
					  (inc fp))))
				(t (store (lines cl fp) token)
				   (cond ((member fp old-marks)
					  (insert-ampersand fp)))
				   (inc fp))))
		      t)
		     (cond ((member token '(#o12 #o15))
			    (setq end-of-first-line t))
			   (t (store (lines cl fp) token)
			      (inc fp)))))))